home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / GFXFX2.ZIP / ROTATE1.PAS < prev    next >
Pascal/Delphi Source File  |  1995-02-14  |  3KB  |  95 lines
  1.  
  2. program _rotate; { ROTATE1.PAS }
  3. { Bumping-and-rotating sphere in mode 13h, by Bas van Gaalen }
  4. uses u_vga,u_pal,u_3d,u_kb;
  5. const
  6.   radius=40; { sphere radius }
  7.   maxpoints=1000; { maximum number of points }
  8.   ptab:array[0..255] of byte=(
  9.     123,121,119,117,115,114,112,110,108,106,104,103,101,99,97,96,94,92,91,
  10.     89,87,86,84,82,81,79,78,76,75,73,72,70,69,67,66,64,63,62,60,59,58,56,
  11.     55,54,52,51,50,49,48,46,45,44,43,42,41,39,38,37,36,35,34,33,32,31,30,
  12.     29,28,27,26,26,25,24,23,22,21,21,20,19,18,17,17,16,15,15,14,13,13,12,
  13.     12,11,10,10,9,9,8,8,7,7,6,6,5,5,5,4,4,4,3,3,3,2,2,2,2,1,1,1,1,1,1,0,0,
  14.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,1,1,1,1,1,2,2,2,2,3,3,3,3,4,4,4,5,5,6,6,
  15.     7,7,7,8,8,9,9,10,11,11,12,12,13,14,14,15,16,16,17,18,19,19,20,21,22,
  16.     23,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,
  17.     46,47,48,49,51,52,53,54,56,57,58,60,61,62,64,65,67,68,69,71,72,74,75,
  18.     77,78,80,82,83,85,86,88,90,91,93,95,96,98,100,102,103,105,107,109,111,
  19.     113,114,116,118,120,122,124,126);
  20.  
  21. var
  22.   points:array[1..maxpoints,0..2] of integer;
  23.   nofpoints:word;
  24.  
  25. {----------------------------------------------------------------------------}
  26.  
  27. procedure initialize;
  28. const
  29.   step=0.3;
  30. var
  31.   alpha,beta:real;
  32.   i:word;
  33.   r,x,y,z:integer;
  34. begin
  35.   writeln('calculating sphere-data...');
  36.   i:=1;
  37.   alpha:=2*pi;
  38.   while alpha>0 do begin
  39.     beta:=pi;
  40.     while beta>0 do begin
  41.       { torus }
  42.       {r:=round(radius*sin(beta));
  43.       x:=round(r*cos(alpha)*sin(beta));
  44.       y:=-round(0.8333*r*cos(beta));
  45.       z:=-round(r*sin(alpha)*sin(beta));}
  46.       { sphere }
  47.       x:=round(radius*cos(alpha)*sin(beta));
  48.       y:=round(radius*cos(beta));
  49.       z:=round(radius*sin(alpha)*sin(beta));
  50.       points[i,0]:=x; points[i,1]:=y; points[i,2]:=z;
  51.       beta:=beta-step;
  52.       inc(i);
  53.       if i>maxpoints then begin
  54.         writeln('to many points, change step...'); halt; end;
  55.     end;
  56.     alpha:=alpha-step;
  57.   end;
  58.   nofpoints:=pred(i);
  59.   setvideo($13);
  60.   for i:=1 to 128 do setrgb(i,10+i shr 2,10+i shr 2,15+i shr 1);
  61. end;
  62.  
  63. procedure bump_n_rotate;
  64. const xst=1; yst=1; zst=1; xdiv:shortint=1;
  65. var
  66.   xp,yp:array[0..maxpoints] of integer;
  67.   objx,n:word;
  68.   x,y,z:integer;
  69.   pc,phix,phiy,phiz:byte;
  70. begin
  71.   objx:=radius; pc:=128; phix:=0; phiy:=0; phiz:=0;
  72.   repeat
  73.     vretrace;
  74.     for n:=1 to nofpoints do begin
  75.       if (xp[n]>=0) and (xp[n]<=319) and (yp[n]>=0) and (yp[n]<=199) then
  76.         putpixel(xp[n],yp[n],0);
  77.       x:=points[n,0]; y:=points[n,1]; z:=points[n,2];
  78.       rotate(x,y,z,phix,phiy,phiz);
  79.       conv3dto2d(xp[n],yp[n],x,y,z);
  80.       xp[n]:=xp[n]+objx;
  81.       yp[n]:=yp[n]+ptab[pc]+radius;
  82.       if (xp[n]>=0) and (xp[n]<=319) and (yp[n]>=0) and (yp[n]<=199) then
  83.         putpixel(xp[n],yp[n],z shr 1+radius);
  84.     end;
  85.     inc(objx,xdiv); if (objx<radius) or (objx>(320-radius)) then xdiv:=-xdiv;
  86.     inc(pc,2); inc(phix,xst); inc(phiy,yst); inc(phiz,zst);
  87.   until keypressed;
  88. end;
  89.  
  90. begin
  91.   initialize;
  92.   bump_n_rotate;
  93.   setvideo(u_lm);
  94. end.
  95.